home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 7 / Amiga Format AFCD07 (Dec 1996, Issue 91).iso / serious / shareware / programming / emacs-complete / fsf / emacs / lisp / diary-lib.el < prev    next >
Lisp/Scheme  |  1994-08-29  |  90KB  |  1,899 lines
  1. ;;; diary-lib.el --- diary functions.
  2.  
  3. ;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; This collection of functions implements the diary features as described
  27. ;; in calendar.el.
  28.  
  29. ;; Comments, corrections, and improvements should be sent to
  30. ;;  Edward M. Reingold               Department of Computer Science
  31. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  32. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  33. ;;                                   Urbana, Illinois 61801
  34.  
  35. ;;; Code:
  36.  
  37. (require 'calendar)
  38.  
  39. ;;;###autoload
  40. (defun diary (&optional arg)
  41.   "Generate the diary window for ARG days starting with the current date.
  42. If no argument is provided, the number of days of diary entries is governed
  43. by the variable `number-of-diary-entries'.  This function is suitable for
  44. execution in a `.emacs' file."
  45.   (interactive "P")
  46.   (let ((d-file (substitute-in-file-name diary-file))
  47.         (date (calendar-current-date)))
  48.     (if (and d-file (file-exists-p d-file))
  49.         (if (file-readable-p d-file)
  50.             (list-diary-entries
  51.              date
  52.              (cond
  53.               (arg (prefix-numeric-value arg))
  54.               ((vectorp number-of-diary-entries)
  55.                (aref number-of-diary-entries (calendar-day-of-week date)))
  56.               (t number-of-diary-entries)))
  57.         (error "Your diary file is not readable!"))
  58.       (error "You don't have a diary file!"))))
  59.  
  60. (defun view-diary-entries (arg)
  61.   "Prepare and display a buffer with diary entries.
  62. Searches the file named in `diary-file' for entries that
  63. match ARG days starting with the date indicated by the cursor position
  64. in the displayed three-month calendar."
  65.   (interactive "p")
  66.   (let ((d-file (substitute-in-file-name diary-file)))
  67.     (if (and d-file (file-exists-p d-file))
  68.         (if (file-readable-p d-file)
  69.             (list-diary-entries (calendar-cursor-to-date t) arg)
  70.           (error "Your diary file is not readable!"))
  71.       (error "You don't have a diary file!"))))
  72.  
  73. (autoload 'check-calendar-holidays "holidays"
  74.   "Check the list of holidays for any that occur on DATE.
  75. The value returned is a list of strings of relevant holiday descriptions.
  76. The holidays are those in the list `calendar-holidays'."
  77.   t)
  78.  
  79.  
  80. (autoload 'calendar-holiday-list "holidays"
  81.   "Form the list of holidays that occur on dates in the calendar window.
  82. The holidays are those in the list `calendar-holidays'."
  83.   t)
  84.  
  85. (autoload 'diary-french-date "cal-french"
  86.   "French calendar equivalent of date diary entry."
  87.   t)
  88.  
  89. (autoload 'diary-mayan-date "cal-mayan"
  90.   "Mayan calendar equivalent of date diary entry."
  91.   t)
  92.  
  93. (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
  94.  
  95. (autoload 'diary-sunrise-sunset "solar"
  96.   "Local time of sunrise and sunset as a diary entry."
  97.   t)
  98.  
  99. (autoload 'diary-sabbath-candles "solar"
  100.   "Local time of candle lighting diary entry--applies if date is a Friday.
  101. No diary entry if there is no sunset on that date."
  102.   t)
  103.  
  104. (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
  105.   "The syntax table used when parsing dates in the diary file.
  106. It is the standard syntax table used in Fundamental mode, but with the
  107. syntax of `*' changed to be a word constituent.")
  108.  
  109. (modify-syntax-entry ?* "w" diary-syntax-table)
  110.  
  111. (defun list-diary-entries (date number)
  112.   "Create and display a buffer containing the relevant lines in diary-file.
  113. The arguments are DATE and NUMBER; the entries selected are those
  114. for NUMBER days starting with date DATE.  The other entries are hidden
  115. using selective display.
  116.  
  117. Returns a list of all relevant diary entries found, if any, in order by date.
  118. The list entries have the form ((month day year) string).  If the variable
  119. `diary-list-include-blanks' is t, this list includes a dummy diary entry
  120. \(consisting of the empty string) for a date with no diary entries.
  121.  
  122. After the list is prepared, the hooks `nongregorian-diary-listing-hook',
  123. `list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
  124. These hooks have the following distinct roles:
  125.  
  126.     `nongregorian-diary-listing-hook' can cull dates from the diary
  127.         and each included file.  Usually used for Hebrew or Islamic
  128.         diary entries in files.  Applied to *each* file.
  129.  
  130.     `list-diary-entries-hook' adds or manipulates diary entries from
  131.         external sources.  Used, for example, to include diary entries
  132.         from other files or to sort the diary entries.  Invoked *once* only,
  133.         before the display hook is run.
  134.  
  135.     `diary-display-hook' does the actual display of information.  If this is
  136.         nil, simple-diary-display will be used.  Use add-hook to set this to
  137.         fancy-diary-display, if desired.  If you want no diary display, use
  138.         add-hook to set this to ignore.
  139.  
  140.     `diary-hook' is run last.  This can be used for an appointment
  141.         notification function."
  142.  
  143.   (if (< 0 number)
  144.       (let* ((original-date date);; save for possible use in the hooks
  145.              (old-diary-syntax-table)
  146.              (diary-entries-list)
  147.              (date-string (calendar-date-string date))
  148.              (d-file (substitute-in-file-name diary-file)))
  149.         (message "Preparing diary...")
  150.         (save-excursion
  151.           (let ((diary-buffer (get-file-buffer d-file)))
  152.             (set-buffer (if diary-buffer
  153.                             diary-buffer
  154.                          (find-file-noselect d-file t))))
  155.           (setq selective-display t)
  156.           (setq selective-display-ellipses nil)
  157.           (setq old-diary-syntax-table (syntax-table))
  158.           (set-syntax-table diary-syntax-table)
  159.           (unwind-protect
  160.             (let ((buffer-read-only nil)
  161.                   (diary-modified (buffer-modified-p))
  162.                   (mark (regexp-quote diary-nonmarking-symbol)))
  163.               (goto-char (1- (point-max)))
  164.               (if (not (looking-at "\^M\\|\n"))
  165.                   (progn
  166.                     (forward-char 1)
  167.                     (insert-string "\^M")))
  168.               (goto-char (point-min))
  169.               (if (not (looking-at "\^M\\|\n"))
  170.                   (insert-string "\^M"))
  171.               (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
  172.               (calendar-for-loop i from 1 to number do
  173.                  (let ((d diary-date-forms)
  174.                        (month (extract-calendar-month date))
  175.                        (day (extract-calendar-day date))
  176.                        (year (extract-calendar-year date))
  177.                        (entry-found (list-sexp-diary-entries date)))
  178.                    (while d
  179.                      (let*
  180.                           ((date-form (if (equal (car (car d)) 'backup)
  181.                                           (cdr (car d))
  182.                                         (car d)))
  183.                           (backup (equal (car (car d)) 'backup))
  184.                           (dayname
  185.                            (concat
  186.                             (calendar-day-name date) "\\|"
  187.                             (substring (calendar-day-name date) 0 3) ".?"))
  188.                           (monthname
  189.                            (concat
  190.                             "\\*\\|"
  191.                             (calendar-month-name month) "\\|"
  192.                             (substring (calendar-month-name month) 0 3) ".?"))
  193.                           (month (concat "\\*\\|0*" (int-to-string month)))
  194.                           (day (concat "\\*\\|0*" (int-to-string day)))
  195.                           (year
  196.                            (concat
  197.                             "\\*\\|0*" (int-to-string year)
  198.                             (if abbreviated-calendar-year
  199.                                 (concat "\\|" (int-to-string (% year 100)))
  200.                               "")))
  201.                           (regexp
  202.                            (concat
  203.                             "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
  204.                             (mapconcat 'eval date-form "\\)\\(")
  205.                             "\\)"))
  206.                           (case-fold-search t))
  207.                        (goto-char (point-min))
  208.                        (while (re-search-forward regexp nil t)
  209.                          (if backup (re-search-backward "\\<" nil t))
  210.                          (if (and (or (char-equal (preceding-char) ?\^M)
  211.                                       (char-equal (preceding-char) ?\n))
  212.                                   (not (looking-at " \\|\^I")))
  213.                              ;;  Diary entry that consists only of date.
  214.                              (backward-char 1)
  215.                            ;; Found a nonempty diary entry--make it visible and
  216.                            ;; add it to the list.
  217.                            (setq entry-found t)
  218.                            (let ((entry-start (point))
  219.                                  (date-start))
  220.                              (re-search-backward "\^M\\|\n\\|\\`")
  221.                              (setq date-start (point))
  222.                              (re-search-forward "\^M\\|\n" nil t 2)
  223.                              (while (looking-at " \\|\^I")
  224.                                (re-search-forward "\^M\\|\n" nil t))
  225.                              (backward-char 1)
  226.                              (subst-char-in-region date-start
  227.                                 (point) ?\^M ?\n t)
  228.                              (add-to-diary-list
  229.                                date (buffer-substring entry-start (point)))))))
  230.                      (setq d (cdr d)))
  231.                    (or entry-found
  232.                        (not diary-list-include-blanks)
  233.                        (setq diary-entries-list 
  234.                              (append diary-entries-list
  235.                                      (list (list date "")))))
  236.                    (setq date
  237.                          (calendar-gregorian-from-absolute
  238.                            (1+ (calendar-absolute-from-gregorian date))))
  239.                    (setq entry-found nil)))
  240.               (set-buffer-modified-p diary-modified))
  241.           (set-syntax-table old-diary-syntax-table))
  242.         (goto-char (point-min))
  243.         (run-hooks 'nongregorian-diary-listing-hook
  244.                    'list-diary-entries-hook)
  245.         (if diary-display-hook
  246.             (run-hooks 'diary-display-hook)
  247.           (simple-diary-display))
  248.         (run-hooks 'diary-hook)
  249.         diary-entries-list))))
  250.  
  251. (defun include-other-diary-files ()
  252.   "Include the diary entries from other diary files with those of diary-file.
  253. This function is suitable for use in `list-diary-entries-hook';
  254. it enables you to use shared diary files together with your own.
  255. The files included are specified in the diaryfile by lines of this form:
  256.         #include \"filename\"
  257. This is recursive; that is, #include directives in diary files thus included
  258. are obeyed.  You can change the `#include' to some other string by
  259. changing the variable `diary-include-string'."
  260.   (goto-char (point-min))
  261.   (while (re-search-forward
  262.           (concat
  263.            "\\(\\`\\|\^M\\|\n\\)"
  264.            (regexp-quote diary-include-string)
  265.            " \"\\([^\"]*\\)\"")
  266.           nil t)
  267.     (let ((diary-file (substitute-in-file-name
  268.                        (buffer-substring (match-beginning 2) (match-end 2))))
  269.           (diary-list-include-blanks nil)
  270.           (list-diary-entries-hook 'include-other-diary-files)
  271.           (diary-display-hook 'ignore)
  272.           (diary-hook nil))
  273.       (if (file-exists-p diary-file)
  274.           (if (file-readable-p diary-file)
  275.               (unwind-protect
  276.                   (setq diary-entries-list
  277.                         (append diary-entries-list
  278.                                 (list-diary-entries original-date number)))
  279.                 (kill-buffer (get-file-buffer diary-file)))
  280.             (beep)
  281.             (message "Can't read included diary file %s" diary-file)
  282.             (sleep-for 2))
  283.         (beep)
  284.         (message "Can't find included diary file %s" diary-file)
  285.         (sleep-for 2))))
  286.     (goto-char (point-min)))
  287.  
  288. (defun simple-diary-display ()
  289.   "Display the diary buffer if there are any relevant entries or holidays."
  290.   (let* ((holiday-list (if holidays-in-diary-buffer
  291.                            (check-calendar-holidays original-date)))
  292.          (msg (format "No diary entries for %s %s"
  293.                       (concat date-string (if holiday-list ":" ""))
  294.                       (mapconcat 'identity holiday-list "; "))))
  295.     (if (or (not diary-entries-list)
  296.             (and (not (cdr diary-entries-list))
  297.                  (string-equal (car (cdr (car diary-entries-list))) "")))
  298.         (if (<= (length msg) (frame-width))
  299.             (message msg)
  300.           (set-buffer (get-buffer-create holiday-buffer))
  301.           (setq buffer-read-only nil)
  302.           (calendar-set-mode-line date-string)
  303.           (erase-buffer)
  304.           (insert (mapconcat 'identity holiday-list "\n"))
  305.           (goto-char (point-min))
  306.           (set-buffer-modified-p nil)
  307.           (setq buffer-read-only t)
  308.           (display-buffer holiday-buffer)
  309.           (message  "No diary entries for %s" date-string))
  310.       (calendar-set-mode-line
  311.        (concat "Diary for " date-string
  312.                (if holiday-list ": " "")
  313.                (mapconcat 'identity holiday-list "; ")))
  314.       (display-buffer (get-file-buffer d-file))
  315.       (message "Preparing diary...done"))))
  316.  
  317. (defun fancy-diary-display ()
  318.   "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
  319. This function is provided for optional use as the `diary-display-hook'."
  320.   (save-excursion;; Turn off selective-display in the diary file's buffer.
  321.     (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
  322.     (let ((diary-modified (buffer-modified-p)))
  323.       (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  324.       (setq selective-display nil)
  325.       (kill-local-variable 'mode-line-format)
  326.       (set-buffer-modified-p diary-modified)))
  327.   (if (or (not diary-entries-list)
  328.           (and (not (cdr diary-entries-list))
  329.                (string-equal (car (cdr (car diary-entries-list))) "")))
  330.       (let* ((holiday-list (if holidays-in-diary-buffer
  331.                                (check-calendar-holidays original-date)))
  332.              (msg (format "No diary entries for %s %s"
  333.                           (concat date-string (if holiday-list ":" ""))
  334.                           (mapconcat 'identity holiday-list "; "))))
  335.         (if (<= (length msg) (frame-width))
  336.             (message msg)
  337.           (set-buffer (get-buffer-create holiday-buffer))
  338.           (setq buffer-read-only nil)
  339.           (calendar-set-mode-line date-string)
  340.           (erase-buffer)
  341.           (insert (mapconcat 'identity holiday-list "\n"))
  342.           (goto-char (point-min))
  343.           (set-buffer-modified-p nil)
  344.           (setq buffer-read-only t)
  345.           (display-buffer holiday-buffer)
  346.           (message  "No diary entries for %s" date-string)))
  347.     (save-excursion;; Prepare the fancy diary buffer.
  348.       (set-buffer (get-buffer-create fancy-diary-buffer))
  349.       (setq buffer-read-only nil)
  350.       (make-local-variable 'mode-line-format)
  351.       (calendar-set-mode-line "Diary Entries")
  352.       (erase-buffer)
  353.       (let ((entry-list diary-entries-list)
  354.             (holiday-list)
  355.             (holiday-list-last-month 1)
  356.             (holiday-list-last-year 1)
  357.             (date (list 0 0 0)))
  358.         (while entry-list
  359.           (if (not (calendar-date-equal date (car (car entry-list))))
  360.               (progn
  361.                 (setq date (car (car entry-list)))
  362.                 (and holidays-in-diary-buffer
  363.                      (calendar-date-compare
  364.                       (list (list holiday-list-last-month
  365.                                   (calendar-last-day-of-month
  366.                                    holiday-list-last-month
  367.                                    holiday-list-last-year)
  368.                                   holiday-list-last-year))
  369.                       (list date))
  370.                      ;; We need to get the holidays for the next 3 months.
  371.                      (setq holiday-list-last-month
  372.                            (extract-calendar-month date))
  373.                      (setq holiday-list-last-year
  374.                            (extract-calendar-year date))
  375.                      (increment-calendar-month
  376.                       holiday-list-last-month holiday-list-last-year 1)
  377.                      (setq holiday-list
  378.                            (let ((displayed-month holiday-list-last-month)
  379.                                  (displayed-year holiday-list-last-year))
  380.                              (calendar-holiday-list)))
  381.                      (increment-calendar-month
  382.                       holiday-list-last-month holiday-list-last-year 1))
  383.                 (let* ((date-string (calendar-date-string date))
  384.                        (date-holiday-list
  385.                         (let ((h holiday-list)
  386.                               (d))
  387.                           ;; Make a list of all holidays for date.
  388.                           (while h
  389.                             (if (calendar-date-equal date (car (car h)))
  390.                                 (setq d (append d (cdr (car h)))))
  391.                             (setq h (cdr h)))
  392.                           d)))
  393.                   (insert (if (= (point) (point-min)) "" ?\n) date-string)
  394.                   (if date-holiday-list (insert ":  "))
  395.                   (let ((l (current-column)))
  396.                     (insert (mapconcat 'identity date-holiday-list
  397.                                        (concat "\n" (make-string l ? )))))
  398.                   (let ((l (current-column)))
  399.                     (insert ?\n (make-string l ?=) ?\n)))))
  400.           (if (< 0 (length (car (cdr (car entry-list)))))
  401.               (insert (car (cdr (car entry-list))) ?\n))
  402.           (setq entry-list (cdr entry-list))))
  403.       (set-buffer-modified-p nil)
  404.       (goto-char (point-min))
  405.       (setq buffer-read-only t)
  406.       (display-buffer fancy-diary-buffer)
  407.       (message "Preparing diary...done"))))
  408.  
  409. (defun print-diary-entries ()
  410.   "Print a hard copy of the diary display.
  411.  
  412. If the simple diary display is being used, prepare a temp buffer with the
  413. visible lines of the diary buffer, add a heading line composed from the mode
  414. line, print the temp buffer, and destroy it.
  415.  
  416. If the fancy diary display is being used, just print the buffer.
  417.  
  418. The hooks given by the variable `print-diary-entries-hook' are called to do
  419. the actual printing."
  420.   (interactive)
  421.   (if (bufferp (get-buffer fancy-diary-buffer))
  422.       (save-excursion
  423.         (set-buffer (get-buffer fancy-diary-buffer))
  424.         (run-hooks 'print-diary-entries-hook))
  425.     (let ((diary-buffer
  426.            (get-file-buffer (substitute-in-file-name diary-file))))
  427.       (if diary-buffer
  428.           (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
  429.                 (heading))
  430.             (save-excursion
  431.               (set-buffer diary-buffer)
  432.               (setq heading
  433.                     (if (not (stringp mode-line-format))
  434.                         "All Diary Entries"
  435.                       (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
  436.                       (substring mode-line-format
  437.                                  (match-beginning 1) (match-end 1))))
  438.               (copy-to-buffer temp-buffer (point-min) (point-max))
  439.               (set-buffer temp-buffer)
  440.               (while (re-search-forward "\^M.*$" nil t)
  441.                 (replace-match ""))
  442.               (goto-char (point-min))
  443.               (insert heading "\n"
  444.                       (make-string (length heading) ?=) "\n")
  445.               (run-hooks 'print-diary-entries-hook)
  446.               (kill-buffer temp-buffer)))
  447.         (error "You don't have a diary buffer!")))))
  448.  
  449. (defun show-all-diary-entries ()
  450.   "Show all of the diary entries in the diary file.
  451. This function gets rid of the selective display of the diary file so that
  452. all entries, not just some, are visible.  If there is no diary buffer, one
  453. is created."
  454.   (interactive)
  455.   (let ((d-file (substitute-in-file-name diary-file)))
  456.     (if (and d-file (file-exists-p d-file))
  457.         (if (file-readable-p d-file)
  458.             (save-excursion
  459.               (let ((diary-buffer (get-file-buffer d-file)))
  460.                 (set-buffer (if diary-buffer
  461.                                 diary-buffer
  462.                               (find-file-noselect d-file t)))
  463.                 (let ((buffer-read-only nil)
  464.                       (diary-modified (buffer-modified-p)))
  465.                   (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  466.                   (setq selective-display nil)
  467.                   (make-local-variable 'mode-line-format)
  468.                   (setq mode-line-format default-mode-line-format)
  469.                   (display-buffer (current-buffer))
  470.                   (set-buffer-modified-p diary-modified))))
  471.           (error "Your diary file is not readable!"))
  472.       (error "You don't have a diary file!"))))
  473.  
  474. (defun diary-name-pattern (string-array &optional fullname)
  475.   "Convert an STRING-ARRAY, an array of strings to a pattern.
  476. The pattern will match any of the strings, either entirely or abbreviated
  477. to three characters.  An abbreviated form will match with or without a period;
  478. If the optional FULLNAME is t, abbreviations will not match, just the full
  479. name."
  480.   (let ((pattern ""))
  481.     (calendar-for-loop i from 0 to (1- (length string-array)) do
  482.       (setq pattern
  483.             (concat
  484.              pattern
  485.              (if (string-equal pattern "") "" "\\|")
  486.              (aref string-array i)
  487.              (if fullname
  488.                  ""
  489.                (concat
  490.                 "\\|"
  491.                 (substring (aref string-array i) 0 3) ".?")))))
  492.     pattern))
  493.  
  494. (defun mark-diary-entries ()
  495.   "Mark days in the calendar window that have diary entries.
  496. Each entry in the diary file visible in the calendar window is marked.
  497. After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
  498. `mark-diary-entries-hook' are run."
  499.   (interactive)
  500.   (setq mark-diary-entries-in-calendar t)
  501.   (let ((d-file (substitute-in-file-name diary-file)))
  502.     (if (and d-file (file-exists-p d-file))
  503.         (if (file-readable-p d-file)
  504.             (save-excursion
  505.               (message "Marking diary entries...")
  506.               (set-buffer (find-file-noselect d-file t))
  507.               (let ((d diary-date-forms)
  508.                     (old-diary-syntax-table))
  509.                 (setq old-diary-syntax-table (syntax-table))
  510.                 (set-syntax-table diary-syntax-table)
  511.                 (while d
  512.                   (let*
  513.                       ((date-form (if (equal (car (car d)) 'backup)
  514.                                       (cdr (car d))
  515.                                     (car d)));; ignore 'backup directive
  516.                        (dayname (diary-name-pattern calendar-day-name-array))
  517.                        (monthname
  518.                         (concat
  519.                          (diary-name-pattern calendar-month-name-array)
  520.                          "\\|\\*"))
  521.                        (month "[0-9]+\\|\\*")
  522.                        (day "[0-9]+\\|\\*")
  523.                        (year "[0-9]+\\|\\*")
  524.                        (l (length date-form))
  525.                        (d-name-pos (- l (length (memq 'dayname date-form))))
  526.                        (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  527.                        (m-name-pos (- l (length (memq 'monthname date-form))))
  528.                        (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  529.                        (d-pos (- l (length (memq 'day date-form))))
  530.                        (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  531.                        (m-pos (- l (length (memq 'month date-form))))
  532.                        (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  533.                        (y-pos (- l (length (memq 'year date-form))))
  534.                        (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  535.                        (regexp
  536.                         (concat
  537.                          "\\(\\`\\|\^M\\|\n\\)\\("
  538.                          (mapconcat 'eval date-form "\\)\\(")
  539.                          "\\)"))
  540.                        (case-fold-search t))
  541.                     (goto-char (point-min))
  542.                     (while (re-search-forward regexp nil t)
  543.                       (let* ((dd-name
  544.                               (if d-name-pos
  545.                                   (buffer-substring
  546.                                    (match-beginning d-name-pos)
  547.                                    (match-end d-name-pos))))
  548.                              (mm-name
  549.                               (if m-name-pos
  550.                                   (buffer-substring
  551.                                    (match-beginning m-name-pos)
  552.                                    (match-end m-name-pos))))
  553.                              (mm (string-to-int
  554.                                   (if m-pos
  555.                                       (buffer-substring
  556.                                        (match-beginning m-pos)
  557.                                        (match-end m-pos))
  558.                                     "")))
  559.                              (dd (string-to-int
  560.                                   (if d-pos
  561.                                       (buffer-substring
  562.                                        (match-beginning d-pos)
  563.                                        (match-end d-pos))
  564.                                     "")))
  565.                              (y-str (if y-pos
  566.                                         (buffer-substring
  567.                                          (match-beginning y-pos)
  568.                                          (match-end y-pos))))
  569.                              (yy (if (not y-str)
  570.                                      0
  571.                                    (if (and (= (length y-str) 2)
  572.                                             abbreviated-calendar-year)
  573.                                        (let* ((current-y
  574.                                                (extract-calendar-year
  575.                                                 (calendar-current-date)))
  576.                                               (y (+ (string-to-int y-str)
  577.                                                     (* 100
  578.                                                        (/ current-y 100)))))
  579.                                          (if (> (- y current-y) 50)
  580.                                              (- y 100)
  581.                                            (if (> (- current-y y) 50)
  582.                                                (+ y 100)
  583.                                              y)))
  584.                                      (string-to-int y-str)))))
  585.                         (if dd-name
  586.                             (mark-calendar-days-named
  587.                              (cdr (assoc (capitalize (substring dd-name 0 3))
  588.                                          (calendar-make-alist
  589.                                           calendar-day-name-array
  590.                                           0
  591.                                           '(lambda (x) (substring x 0 3))))))
  592.                           (if mm-name
  593.                               (if (string-equal mm-name "*")
  594.                                   (setq mm 0)
  595.                                 (setq mm
  596.                                       (cdr (assoc
  597.                                             (capitalize
  598.                                              (substring mm-name 0 3))
  599.                                             (calendar-make-alist
  600.                                              calendar-month-name-array
  601.                                              1
  602.                                              '(lambda (x) (substring x 0 3)))
  603.                                             )))))
  604.                           (mark-calendar-date-pattern mm dd yy))))
  605.                     (setq d (cdr d))))
  606.                 (mark-sexp-diary-entries)
  607.                 (run-hooks 'nongregorian-diary-marking-hook
  608.                            'mark-diary-entries-hook)
  609.                 (set-syntax-table old-diary-syntax-table)
  610.                 (message "Marking diary entries...done")))
  611.           (error "Your diary file is not readable!"))
  612.       (error "You don't have a diary file!"))))
  613.  
  614. (defun mark-sexp-diary-entries ()
  615.   "Mark days in the calendar window that have sexp diary entries.
  616. Each entry in the diary file (or included files) visible in the calendar window
  617. is marked.  See the documentation for the function `list-sexp-diary-entries'."
  618.   (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
  619.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
  620.          (m)
  621.          (y)
  622.          (first-date)
  623.          (last-date))
  624.     (save-excursion
  625.       (set-buffer calendar-buffer)
  626.       (setq m displayed-month)
  627.       (setq y displayed-year))
  628.     (increment-calendar-month m y -1)
  629.     (setq first-date
  630.           (calendar-absolute-from-gregorian (list m 1 y)))
  631.     (increment-calendar-month m y 2)
  632.     (setq last-date
  633.           (calendar-absolute-from-gregorian
  634.            (list m (calendar-last-day-of-month m y) y)))
  635.     (goto-char (point-min))
  636.     (while (re-search-forward s-entry nil t)
  637.       (backward-char 1)
  638.       (let ((sexp-start (point))
  639.             (sexp)
  640.             (entry)
  641.             (entry-start)
  642.             (line-start))
  643.         (forward-sexp)
  644.         (setq sexp (buffer-substring sexp-start (point)))
  645.         (save-excursion
  646.           (re-search-backward "\^M\\|\n\\|\\`")
  647.           (setq line-start (point)))
  648.         (forward-char 1)
  649.         (if (and (or (char-equal (preceding-char) ?\^M)
  650.                      (char-equal (preceding-char) ?\n))
  651.                  (not (looking-at " \\|\^I")))
  652.             (progn;; Diary entry consists only of the sexp
  653.               (backward-char 1)
  654.               (setq entry ""))
  655.           (setq entry-start (point))
  656.           (re-search-forward "\^M\\|\n" nil t)
  657.           (while (looking-at " \\|\^I")
  658.             (re-search-forward "\^M\\|\n" nil t))
  659.           (backward-char 1)
  660.           (setq entry (buffer-substring entry-start (point)))
  661.           (while (string-match "[\^M]" entry)
  662.             (aset entry (match-beginning 0) ?\n )))
  663.         (calendar-for-loop date from first-date to last-date do
  664.           (if (diary-sexp-entry sexp entry
  665.                                 (calendar-gregorian-from-absolute date))
  666.               (mark-visible-calendar-date
  667.                (calendar-gregorian-from-absolute date))))))))
  668.  
  669. (defun mark-included-diary-files ()
  670.   "Mark the diary entries from other diary files with those of the diary file.
  671. This function is suitable for use as the `mark-diary-entries-hook'; it enables
  672. you to use shared diary files together with your own.  The files included are
  673. specified in the diary-file by lines of this form:
  674.         #include \"filename\"
  675. This is recursive; that is, #include directives in diary files thus included
  676. are obeyed.  You can change the `#include' to some other string by
  677. changing the variable `diary-include-string'."
  678.   (goto-char (point-min))
  679.   (while (re-search-forward
  680.           (concat
  681.            "\\(\\`\\|\^M\\|\n\\)"
  682.            (regexp-quote diary-include-string)
  683.            " \"\\([^\"]*\\)\"")
  684.           nil t)
  685.     (let ((diary-file (substitute-in-file-name
  686.                        (buffer-substring (match-beginning 2) (match-end 2))))
  687.           (mark-diary-entries-hook 'mark-included-diary-files))
  688.       (if (file-exists-p diary-file)
  689.           (if (file-readable-p diary-file)
  690.               (progn
  691.                 (mark-diary-entries)
  692.                 (kill-buffer (get-file-buffer diary-file)))
  693.             (beep)
  694.             (message "Can't read included diary file %s" diary-file)
  695.             (sleep-for 2))
  696.         (beep)
  697.         (message "Can't find included diary file %s" diary-file)
  698.         (sleep-for 2))))
  699.   (goto-char (point-min)))
  700.  
  701. (defun mark-calendar-days-named (dayname)
  702.   "Mark all dates in the calendar window that are day DAYNAME of the week.
  703. 0 means all Sundays, 1 means all Mondays, and so on."
  704.   (save-excursion
  705.     (set-buffer calendar-buffer)
  706.     (let ((prev-month displayed-month)
  707.           (prev-year displayed-year)
  708.           (succ-month displayed-month)
  709.           (succ-year displayed-year)
  710.           (last-day)
  711.           (day))
  712.       (increment-calendar-month succ-month succ-year 1)
  713.       (increment-calendar-month prev-month prev-year -1)
  714.       (setq day (calendar-absolute-from-gregorian
  715.                  (calendar-nth-named-day 1 dayname prev-month prev-year)))
  716.       (setq last-day (calendar-absolute-from-gregorian
  717.                  (calendar-nth-named-day -1 dayname succ-month succ-year)))
  718.       (while (<= day last-day)
  719.         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
  720.         (setq day (+ day 7))))))
  721.  
  722. (defun mark-calendar-date-pattern (month day year)
  723.   "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  724. A value of 0 in any position is a wildcard."
  725.   (save-excursion
  726.     (set-buffer calendar-buffer)
  727.     (let ((m displayed-month)
  728.           (y displayed-year))
  729.       (increment-calendar-month m y -1)
  730.       (calendar-for-loop i from 0 to 2 do
  731.           (mark-calendar-month m y month day year)
  732.           (increment-calendar-month m y 1)))))
  733.  
  734. (defun mark-calendar-month (month year p-month p-day p-year)
  735.   "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  736. A value of 0 in any position of the pattern is a wildcard."
  737.   (if (or (and (= month p-month)
  738.                (or (= p-year 0) (= year p-year)))
  739.           (and (= p-month 0)
  740.                (or (= p-year 0) (= year p-year))))
  741.       (if (= p-day 0)
  742.           (calendar-for-loop
  743.               i from 1 to (calendar-last-day-of-month month year) do
  744.             (mark-visible-calendar-date (list month i year)))
  745.         (mark-visible-calendar-date (list month p-day year)))))
  746.  
  747. (defun sort-diary-entries ()
  748.   "Sort the list of diary entries by time of day."
  749.   (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
  750.  
  751. (defun diary-entry-compare (e1 e2)
  752.   "Returns t if E1 is earlier than E2."
  753.   (or (calendar-date-compare e1 e2)
  754.       (and (calendar-date-equal (car e1) (car e2))
  755.            (< (diary-entry-time (car (cdr e1)))
  756.               (diary-entry-time (car (cdr e2)))))))
  757.  
  758. (defun diary-entry-time (s)
  759.   "Time at the beginning of the string S in a military-style integer.
  760. For example, returns 1325 for 1:25pm.  Returns -9999 if no time is recognized.
  761. The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
  762. and XX:XXam or XX:XXpm."
  763.   (cond ((string-match;; Military time  
  764.           "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
  765.          (+ (* 100 (string-to-int
  766.                     (substring s (match-beginning 1) (match-end 1))))
  767.             (string-to-int (substring s (match-beginning 2) (match-end 2)))))
  768.         ((string-match;; Hour only  XXam or XXpm
  769.           "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
  770.          (+ (* 100 (% (string-to-int
  771.                          (substring s (match-beginning 1) (match-end 1)))
  772.                         12))
  773.             (if (string-equal "a"
  774.                               (substring s (match-beginning 2) (match-end 2)))
  775.                 0 1200)))
  776.         ((string-match;; Hour and minute  XX:XXam or XX:XXpm
  777.           "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
  778.          (+ (* 100 (% (string-to-int
  779.                          (substring s (match-beginning 1) (match-end 1)))
  780.                         12))
  781.             (string-to-int (substring s (match-beginning 2) (match-end 2)))
  782.             (if (string-equal "a"
  783.                               (substring s (match-beginning 3) (match-end 3)))
  784.                 0 1200)))
  785.         (t -9999)));; Unrecognizable
  786.  
  787. (defun list-hebrew-diary-entries ()
  788.   "Add any Hebrew date entries from the diary file to `diary-entries-list'.
  789. Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
  790. \(normally an `H').  The same diary date forms govern the style of the Hebrew
  791. calendar entries, except that the Hebrew month names must be spelled in full.
  792. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  793. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  794. common Hebrew year.  If a Hebrew date diary entry begins with a
  795. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  796. not be marked in the calendar.  This function is provided for use with the
  797. `nongregorian-diary-listing-hook'."
  798.   (if (< 0 number)
  799.       (let ((buffer-read-only nil)
  800.             (diary-modified (buffer-modified-p))
  801.             (gdate original-date)
  802.             (mark (regexp-quote diary-nonmarking-symbol)))
  803.         (calendar-for-loop i from 1 to number do
  804.            (let* ((d diary-date-forms)
  805.                   (hdate (calendar-hebrew-from-absolute 
  806.                           (calendar-absolute-from-gregorian gdate)))
  807.                   (month (extract-calendar-month hdate))
  808.                   (day (extract-calendar-day hdate))
  809.                   (year (extract-calendar-year hdate)))
  810.              (while d
  811.                (let*
  812.                    ((date-form (if (equal (car (car d)) 'backup)
  813.                                    (cdr (car d))
  814.                                  (car d)))
  815.                     (backup (equal (car (car d)) 'backup))
  816.                     (dayname
  817.                      (concat
  818.                       (calendar-day-name gdate) "\\|"
  819.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  820.                     (calendar-month-name-array
  821.                      calendar-hebrew-month-name-array-leap-year)
  822.                     (monthname
  823.                      (concat
  824.                       "\\*\\|"
  825.                       (calendar-month-name month)))
  826.                     (month (concat "\\*\\|0*" (int-to-string month)))
  827.                     (day (concat "\\*\\|0*" (int-to-string day)))
  828.                     (year
  829.                      (concat
  830.                       "\\*\\|0*" (int-to-string year)
  831.                       (if abbreviated-calendar-year
  832.                           (concat "\\|" (int-to-string (% year 100)))
  833.                         "")))
  834.                     (regexp
  835.                      (concat
  836.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  837.                       (regexp-quote hebrew-diary-entry-symbol)
  838.                       "\\("
  839.                       (mapconcat 'eval date-form "\\)\\(")
  840.                       "\\)"))
  841.                     (case-fold-search t))
  842.                  (goto-char (point-min))
  843.                  (while (re-search-forward regexp nil t)
  844.                    (if backup (re-search-backward "\\<" nil t))
  845.                    (if (and (or (char-equal (preceding-char) ?\^M)
  846.                                 (char-equal (preceding-char) ?\n))
  847.                             (not (looking-at " \\|\^I")))
  848.                        ;;  Diary entry that consists only of date.
  849.                        (backward-char 1)
  850.                      ;;  Found a nonempty diary entry--make it visible and
  851.                      ;;  add it to the list.
  852.                      (let ((entry-start (point))
  853.                            (date-start))
  854.                        (re-search-backward "\^M\\|\n\\|\\`")
  855.                        (setq date-start (point))
  856.                        (re-search-forward "\^M\\|\n" nil t 2)
  857.                        (while (looking-at " \\|\^I")
  858.                          (re-search-forward "\^M\\|\n" nil t))
  859.                        (backward-char 1)
  860.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  861.                        (add-to-diary-list
  862.                          gdate (buffer-substring entry-start (point)))))))
  863.                (setq d (cdr d))))
  864.            (setq gdate
  865.                  (calendar-gregorian-from-absolute
  866.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  867.            (set-buffer-modified-p diary-modified))
  868.         (goto-char (point-min))))
  869.  
  870. (defun mark-hebrew-diary-entries ()
  871.   "Mark days in the calendar window that have Hebrew date diary entries.
  872. Each entry in diary-file (or included files) visible in the calendar window
  873. is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
  874. \(normally an `H').  The same diary-date-forms govern the style of the Hebrew
  875. calendar entries, except that the Hebrew month names must be spelled in full.
  876. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  877. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  878. common Hebrew year.  Hebrew date diary entries that begin with a
  879. diary-nonmarking symbol will not be marked in the calendar.  This function
  880. is provided for use as part of the nongregorian-diary-marking-hook."
  881.   (let ((d diary-date-forms))
  882.     (while d
  883.       (let*
  884.           ((date-form (if (equal (car (car d)) 'backup)
  885.                           (cdr (car d))
  886.                         (car d)));; ignore 'backup directive
  887.            (dayname (diary-name-pattern calendar-day-name-array))
  888.            (monthname
  889.             (concat
  890.              (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
  891.              "\\|\\*"))
  892.            (month "[0-9]+\\|\\*")
  893.            (day "[0-9]+\\|\\*")
  894.            (year "[0-9]+\\|\\*")
  895.            (l (length date-form))
  896.            (d-name-pos (- l (length (memq 'dayname date-form))))
  897.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  898.            (m-name-pos (- l (length (memq 'monthname date-form))))
  899.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  900.            (d-pos (- l (length (memq 'day date-form))))
  901.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  902.            (m-pos (- l (length (memq 'month date-form))))
  903.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  904.            (y-pos (- l (length (memq 'year date-form))))
  905.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  906.            (regexp
  907.             (concat
  908.              "\\(\\`\\|\^M\\|\n\\)"
  909.              (regexp-quote hebrew-diary-entry-symbol)
  910.              "\\("
  911.              (mapconcat 'eval date-form "\\)\\(")
  912.              "\\)"))
  913.            (case-fold-search t))
  914.         (goto-char (point-min))
  915.         (while (re-search-forward regexp nil t)
  916.           (let* ((dd-name
  917.                   (if d-name-pos
  918.                       (buffer-substring
  919.                        (match-beginning d-name-pos)
  920.                        (match-end d-name-pos))))
  921.                  (mm-name
  922.                   (if m-name-pos
  923.                       (buffer-substring
  924.                        (match-beginning m-name-pos)
  925.                        (match-end m-name-pos))))
  926.                  (mm (string-to-int
  927.                       (if m-pos
  928.                           (buffer-substring
  929.                            (match-beginning m-pos)
  930.                            (match-end m-pos))
  931.                         "")))
  932.                  (dd (string-to-int
  933.                       (if d-pos
  934.                           (buffer-substring
  935.                            (match-beginning d-pos)
  936.                            (match-end d-pos))
  937.                         "")))
  938.                  (y-str (if y-pos
  939.                             (buffer-substring
  940.                              (match-beginning y-pos)
  941.                              (match-end y-pos))))
  942.                  (yy (if (not y-str)
  943.                          0
  944.                        (if (and (= (length y-str) 2)
  945.                                 abbreviated-calendar-year)
  946.                            (let* ((current-y
  947.                                    (extract-calendar-year
  948.                                     (calendar-hebrew-from-absolute
  949.                                      (calendar-absolute-from-gregorian
  950.                                       (calendar-current-date)))))
  951.                                   (y (+ (string-to-int y-str)
  952.                                         (* 100 (/ current-y 100)))))
  953.                              (if (> (- y current-y) 50)
  954.                                  (- y 100)
  955.                                (if (> (- current-y y) 50)
  956.                                    (+ y 100)
  957.                                  y)))
  958.                          (string-to-int y-str)))))
  959.             (if dd-name
  960.                 (mark-calendar-days-named
  961.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  962.                              (calendar-make-alist
  963.                                calendar-day-name-array
  964.                                0
  965.                               '(lambda (x) (substring x 0 3))))))
  966.               (if mm-name
  967.                   (if (string-equal mm-name "*")
  968.                       (setq mm 0)
  969.                     (setq
  970.                       mm
  971.                       (cdr 
  972.                         (assoc
  973.                           (capitalize mm-name)
  974.                             (calendar-make-alist
  975.                                calendar-hebrew-month-name-array-leap-year))))))
  976.               (mark-hebrew-calendar-date-pattern mm dd yy)))))
  977.       (setq d (cdr d)))))
  978.  
  979. (defun mark-hebrew-calendar-date-pattern (month day year)
  980.   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
  981. A value of 0 in any position is a wildcard."
  982.   (save-excursion
  983.     (set-buffer calendar-buffer)
  984.     (if (and (/= 0 month) (/= 0 day))
  985.         (if (/= 0 year)
  986.             ;; Fully specified Hebrew date.
  987.             (let ((date (calendar-gregorian-from-absolute
  988.                          (calendar-absolute-from-hebrew
  989.                           (list month day year)))))
  990.               (if (calendar-date-is-visible-p date)
  991.                   (mark-visible-calendar-date date)))
  992.           ;; Month and day in any year--this taken from the holiday stuff.
  993.           (if (memq displayed-month;;  This test is only to speed things up a
  994.                     (list          ;;  bit; it works fine without the test too.
  995.                      (if (< 11 month) (- month 11) (+ month 1))
  996.                      (if (< 10 month) (- month 10) (+ month 2))
  997.                      (if (<  9 month) (- month  9) (+ month 3))
  998.                      (if (<  8 month) (- month  8) (+ month 4))
  999.                      (if (<  7 month) (- month  7) (+ month 5))))
  1000.               (let ((m1 displayed-month)
  1001.                     (y1 displayed-year)
  1002.                     (m2 displayed-month)
  1003.                     (y2 displayed-year)
  1004.                     (year))
  1005.                 (increment-calendar-month m1 y1 -1)
  1006.                 (increment-calendar-month m2 y2 1)
  1007.                 (let* ((start-date (calendar-absolute-from-gregorian
  1008.                                     (list m1 1 y1)))
  1009.                        (end-date (calendar-absolute-from-gregorian
  1010.                                   (list m2
  1011.                                         (calendar-last-day-of-month m2 y2)
  1012.                                         y2)))
  1013.                        (hebrew-start
  1014.                         (calendar-hebrew-from-absolute start-date))
  1015.                        (hebrew-end (calendar-hebrew-from-absolute end-date))
  1016.                        (hebrew-y1 (extract-calendar-year hebrew-start))
  1017.                        (hebrew-y2 (extract-calendar-year hebrew-end)))
  1018.                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
  1019.                   (let ((date (calendar-gregorian-from-absolute
  1020.                                (calendar-absolute-from-hebrew
  1021.                                 (list month day year)))))
  1022.                     (if (calendar-date-is-visible-p date)
  1023.                         (mark-visible-calendar-date date)))))))
  1024.       ;; Not one of the simple cases--check all visible dates for match.
  1025.       ;; Actually, the following code takes care of ALL of the cases, but
  1026.       ;; it's much too slow to be used for the simple (common) cases.
  1027.       (let ((m displayed-month)
  1028.             (y displayed-year)
  1029.             (first-date)
  1030.             (last-date))
  1031.         (increment-calendar-month m y -1)
  1032.         (setq first-date
  1033.               (calendar-absolute-from-gregorian
  1034.                (list m 1 y)))
  1035.         (increment-calendar-month m y 2)
  1036.         (setq last-date
  1037.               (calendar-absolute-from-gregorian
  1038.                (list m (calendar-last-day-of-month m y) y)))
  1039.         (calendar-for-loop date from first-date to last-date do
  1040.           (let* ((h-date (calendar-hebrew-from-absolute date))
  1041.                  (h-month (extract-calendar-month h-date))
  1042.                  (h-day (extract-calendar-day h-date))
  1043.                  (h-year (extract-calendar-year h-date)))
  1044.             (and (or (zerop month)
  1045.                      (= month h-month))
  1046.                  (or (zerop day)
  1047.                      (= day h-day))
  1048.                  (or (zerop year)
  1049.                      (= year h-year))
  1050.                  (mark-visible-calendar-date
  1051.                   (calendar-gregorian-from-absolute date)))))))))
  1052.  
  1053. (defun list-sexp-diary-entries (date)
  1054.   "Add sexp entries for DATE from the diary file to `diary-entries-list'.
  1055. Also, Make them visible in the diary file.  Returns t if any entries were
  1056. found.
  1057.  
  1058. Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
  1059. `%%').  The form of a sexp diary entry is
  1060.  
  1061.                   %%(SEXP) ENTRY
  1062.  
  1063. Both ENTRY and DATE are globally available when the SEXP is evaluated.  If the
  1064. SEXP yields the value nil, the diary entry does not apply.  If it yields a
  1065. non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
  1066. string, that string will be the diary entry in the fancy diary display.
  1067.  
  1068. For example, the following diary entry will apply to the 21st of the month
  1069. if it is a weekday and the Friday before if the 21st is on a weekend:
  1070.  
  1071.       &%%(let ((dayname (calendar-day-of-week date))
  1072.                (day (extract-calendar-day date)))
  1073.            (or
  1074.              (and (= day 21) (memq dayname '(1 2 3 4 5)))
  1075.              (and (memq day '(19 20)) (= dayname 5)))
  1076.          ) UIUC pay checks deposited
  1077.  
  1078. A number of built-in functions are available for this type of diary entry:
  1079.  
  1080.       %%(diary-float MONTH DAYNAME N) text
  1081.                   Entry will appear on the Nth DAYNAME of MONTH.
  1082.                   (DAYNAME=0 means Sunday, 1 means Monday, and so on;
  1083.                   if N is negative it counts backward from the end of
  1084.                   the month.  MONTH can be a list of months, a single
  1085.                   month, or t to specify all months.
  1086.  
  1087.       %%(diary-block M1 D1 Y1 M2 D2 Y2) text
  1088.                   Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
  1089.                   inclusive.  (If `european-calendar-style' is t, the
  1090.                   order of the parameters should be changed to D1, M1, Y1,
  1091.                   D2, M2, Y2.)
  1092.  
  1093.       %%(diary-anniversary MONTH DAY YEAR) text
  1094.                   Entry will appear on anniversary dates of MONTH DAY, YEAR.
  1095.                   (If `european-calendar-style' is t, the order of the
  1096.                   parameters should be changed to DAY, MONTH, YEAR.)  Text
  1097.                   can contain %d or %d%s; %d will be replaced by the number
  1098.                   of years since the MONTH DAY, YEAR and %s will be replaced
  1099.                   by the ordinal ending of that number (that is, `st', `nd',
  1100.                   `rd' or `th', as appropriate.  The anniversary of February
  1101.                   29 is considered to be March 1 in a non-leap year.
  1102.  
  1103.       %%(diary-cyclic N MONTH DAY YEAR) text
  1104.                   Entry will appear every N days, starting MONTH DAY, YEAR.
  1105.                   (If `european-calendar-style' is t, the order of the
  1106.                   parameters should be changed to N, DAY, MONTH, YEAR.)  Text
  1107.                   can contain %d or %d%s; %d will be replaced by the number
  1108.                   of repetitions since the MONTH DAY, YEAR and %s will
  1109.                   be replaced by the ordinal ending of that number (that is,
  1110.                   `st', `nd', `rd' or `th', as appropriate.
  1111.  
  1112.       %%(diary-day-of-year)
  1113.                   Diary entries giving the day of the year and the number of
  1114.                   days remaining in the year will be made every day.  Note
  1115.                   that since there is no text, it makes sense only if the
  1116.                   fancy diary display is used.
  1117.  
  1118.       %%(diary-iso-date)
  1119.                   Diary entries giving the corresponding ISO commercial date
  1120.                   will be made every day.  Note that since there is no text,
  1121.                   it makes sense only if the fancy diary display is used.
  1122.  
  1123.       %%(diary-french-date)
  1124.                   Diary entries giving the corresponding French Revolutionary
  1125.                   date will be made every day.  Note that since there is no
  1126.                   text, it makes sense only if the fancy diary display is used.
  1127.  
  1128.       %%(diary-islamic-date)
  1129.                   Diary entries giving the corresponding Islamic date will be
  1130.                   made every day.  Note that since there is no text, it
  1131.                   makes sense only if the fancy diary display is used.
  1132.  
  1133.       %%(diary-hebrew-date)
  1134.                   Diary entries giving the corresponding Hebrew date will be
  1135.                   made every day.  Note that since there is no text, it
  1136.                   makes sense only if the fancy diary display is used.
  1137.  
  1138.       %%(diary-astro-day-number) Diary entries giving the corresponding
  1139.                   astronomical (Julian) day number will be made every day.
  1140.                   Note that since there is no text, it makes sense only if the
  1141.                   fancy diary display is used.
  1142.  
  1143.       %%(diary-julian-date) Diary entries giving the corresponding
  1144.                  Julian date will be made every day.  Note that since
  1145.                  there is no text, it makes sense only if the fancy diary
  1146.                  display is used.
  1147.  
  1148.       %%(diary-sunrise-sunset)
  1149.                   Diary entries giving the local times of sunrise and sunset
  1150.                   will be made every day.  Note that since there is no text,
  1151.                   it makes sense only if the fancy diary display is used.
  1152.                   Floating point required.
  1153.  
  1154.       %%(diary-phases-of-moon)
  1155.                   Diary entries giving the times of the phases of the moon
  1156.                   will be when appropriate.  Note that since there is no text,
  1157.                   it makes sense only if the fancy diary display is used.
  1158.                   Floating point required.
  1159.  
  1160.       %%(diary-yahrzeit MONTH DAY YEAR) text
  1161.                   Text is assumed to be the name of the person; the date is
  1162.                   the date of death on the *civil* calendar.  The diary entry
  1163.                   will appear on the proper Hebrew-date anniversary and on the
  1164.                   day before.  (If `european-calendar-style' is t, the order
  1165.                   of the parameters should be changed to DAY, MONTH, YEAR.)
  1166.                   
  1167.       %%(diary-rosh-hodesh)
  1168.                   Diary entries will be made on the dates of Rosh Hodesh on
  1169.                   the Hebrew calendar.  Note that since there is no text, it
  1170.                   makes sense only if the fancy diary display is used.
  1171.  
  1172.       %%(diary-parasha)
  1173.                   Diary entries giving the weekly parasha will be made on
  1174.                   every Saturday.  Note that since there is no text, it
  1175.                   makes sense only if the fancy diary display is used.
  1176.  
  1177.       %%(diary-omer)
  1178.                   Diary entries giving the omer count will be made every day
  1179.                   from Passover to Shavuoth.  Note that since there is no text,
  1180.                   it makes sense only if the fancy diary display is used.
  1181.  
  1182. Marking these entries is *extremely* time consuming, so these entries are
  1183. best if they are nonmarking."
  1184.   (let* ((mark (regexp-quote diary-nonmarking-symbol))
  1185.          (sexp-mark (regexp-quote sexp-diary-entry-symbol))
  1186.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
  1187.          (entry-found))
  1188.     (goto-char (point-min))
  1189.     (while (re-search-forward s-entry nil t)
  1190.       (backward-char 1)
  1191.       (let ((sexp-start (point))
  1192.             (sexp)
  1193.             (entry)
  1194.             (entry-start)
  1195.             (line-start))
  1196.         (forward-sexp)
  1197.         (setq sexp (buffer-substring sexp-start (point)))
  1198.         (save-excursion
  1199.           (re-search-backward "\^M\\|\n\\|\\`")
  1200.           (setq line-start (point)))
  1201.         (forward-char 1)
  1202.         (if (and (or (char-equal (preceding-char) ?\^M)
  1203.                      (char-equal (preceding-char) ?\n))
  1204.                  (not (looking-at " \\|\^I")))
  1205.             (progn;; Diary entry consists only of the sexp
  1206.               (backward-char 1)
  1207.               (setq entry ""))
  1208.           (setq entry-start (point))
  1209.           (re-search-forward "\^M\\|\n" nil t)
  1210.           (while (looking-at " \\|\^I")
  1211.             (re-search-forward "\^M\\|\n" nil t))
  1212.           (backward-char 1)
  1213.           (setq entry (buffer-substring entry-start (point)))
  1214.           (while (string-match "[\^M]" entry)
  1215.             (aset entry (match-beginning 0) ?\n )))
  1216.         (let ((diary-entry (diary-sexp-entry sexp entry date)))
  1217.           (if diary-entry
  1218.               (subst-char-in-region line-start (point) ?\^M ?\n t))
  1219.           (add-to-diary-list date diary-entry)
  1220.           (setq entry-found (or entry-found diary-entry)))))
  1221.     entry-found))
  1222.  
  1223. (defun diary-sexp-entry (sexp entry date)
  1224.   "Process a SEXP diary ENTRY for DATE."
  1225.   (let ((result (if calendar-debug-sexp
  1226.                   (let ((stack-trace-on-error t))
  1227.                     (eval (car (read-from-string sexp))))
  1228.                   (condition-case nil
  1229.                       (eval (car (read-from-string sexp)))
  1230.                     (error
  1231.                      (beep)
  1232.                      (message "Bad sexp at line %d in %s: %s"
  1233.                               (save-excursion
  1234.                                 (save-restriction
  1235.                                   (narrow-to-region 1 (point))
  1236.                                   (goto-char (point-min))
  1237.                                   (let ((lines 1))
  1238.                                     (while (re-search-forward "\n\\|\^M" nil t)
  1239.                                       (setq lines (1+ lines)))
  1240.                                     lines)))
  1241.                               diary-file sexp)
  1242.                      (sleep-for 2))))))
  1243.     (if (stringp result)
  1244.         result
  1245.       (if result
  1246.           entry
  1247.         nil))))
  1248.  
  1249. (defun diary-block (m1 d1 y1 m2 d2 y2)
  1250.   "Block diary entry.
  1251. Entry applies if date is between two dates.  Order of the parameters is
  1252. M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
  1253. D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
  1254.   (let ((date1 (calendar-absolute-from-gregorian
  1255.                 (if european-calendar-style
  1256.                     (list d1 m1 y1)
  1257.                   (list m1 d1 y1))))
  1258.         (date2 (calendar-absolute-from-gregorian
  1259.                 (if european-calendar-style
  1260.                     (list d2 m2 y2)
  1261.                   (list m2 d2 y2))))
  1262.         (d (calendar-absolute-from-gregorian date)))
  1263.     (if (and (<= date1 d) (<= d date2))
  1264.         entry)))
  1265.  
  1266. (defun diary-float (month dayname n)
  1267.   "Floating diary entry--entry applies if date is the nth dayname of month.
  1268. Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
  1269. t, or an integer.  The constant t means all months.  If N is negative, count
  1270. backward from the end of the month."
  1271.   (let ((m (extract-calendar-month date))
  1272.         (y (extract-calendar-year date)))
  1273.     (if (and
  1274.          (or (and (listp month) (memq m month))
  1275.              (equal m month)
  1276.              (eq month t))
  1277.          (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
  1278.         entry)))
  1279.  
  1280. (defun diary-anniversary (month day year)
  1281.   "Anniversary diary entry.
  1282. Entry applies if date is the anniversary of MONTH, DAY, YEAR if
  1283. `european-calendar-style' is nil, and DAY, MONTH, YEAR if
  1284. `european-calendar-style' is t.  Diary entry can contain `%d' or `%d%s'; the
  1285. %d will be replaced by the number of years since the MONTH DAY, YEAR and the
  1286. %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
  1287. `rd' or `th', as appropriate.  The anniversary of February 29 is considered
  1288. to be March 1 in non-leap years."
  1289.   (let* ((d (if european-calendar-style
  1290.                 month
  1291.               day))
  1292.          (m (if european-calendar-style
  1293.                 day
  1294.               month))
  1295.          (y (extract-calendar-year date))
  1296.          (diff (- y year)))
  1297.     (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
  1298.         (setq m 3
  1299.               d 1))
  1300.     (if (and (> diff 0) (calendar-date-equal (list m d y) date))
  1301.         (format entry diff (diary-ordinal-suffix diff)))))
  1302.  
  1303. (defun diary-cyclic (n month day year)
  1304.   "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
  1305. If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
  1306. ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
  1307. years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
  1308. ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
  1309.   (let* ((d (if european-calendar-style
  1310.                 month
  1311.               day))
  1312.          (m (if european-calendar-style
  1313.                 day
  1314.               month))
  1315.          (diff (- (calendar-absolute-from-gregorian date)
  1316.                   (calendar-absolute-from-gregorian
  1317.                    (list m d year))))
  1318.          (cycle (/ diff n)))
  1319.     (if (and (>= diff 0) (zerop (% diff n)))
  1320.         (format entry cycle (diary-ordinal-suffix cycle)))))
  1321.  
  1322. (defun diary-ordinal-suffix (n)
  1323.   "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
  1324.   (if (or (memq (% n 100) '(11 12 13))
  1325.       (< 3 (% n 10)))
  1326.       "th"
  1327.     (aref ["th" "st" "nd" "rd"] (% n 10))))
  1328.  
  1329. (defun diary-day-of-year ()
  1330.   "Day of year and number of days remaining in the year of date diary entry."
  1331.   (calendar-day-of-year-string date))
  1332.  
  1333. (defun diary-iso-date ()
  1334.   "ISO calendar equivalent of date diary entry."
  1335.   (format "ISO date: %s" (calendar-iso-date-string date)))
  1336.  
  1337. (defun diary-islamic-date ()
  1338.   "Islamic calendar equivalent of date diary entry."
  1339.   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
  1340.     (if (string-equal i "")
  1341.         "Date is pre-Islamic"
  1342.       (format "Islamic date (until sunset): %s" i))))
  1343.  
  1344. (defun diary-hebrew-date ()
  1345.   "Hebrew calendar equivalent of date diary entry."
  1346.   (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
  1347.  
  1348. (defun diary-julian-date ()
  1349.   "Julian calendar equivalent of date diary entry."
  1350.   (format "Julian date: %s" (calendar-julian-date-string date)))
  1351.  
  1352. (defun diary-astro-day-number ()
  1353.   "Astronomical (Julian) day number diary entry."
  1354.   (format "Astronomical (Julian) day number %s"
  1355.           (calendar-astro-date-string date)))
  1356.  
  1357. (defun diary-omer ()
  1358.   "Omer count diary entry.
  1359. Entry applies if date is within 50 days after Passover."
  1360.   (let* ((passover
  1361.           (calendar-absolute-from-hebrew
  1362.            (list 1 15 (+ (extract-calendar-year date) 3760))))
  1363.          (omer (- (calendar-absolute-from-gregorian date) passover))
  1364.          (week (/ omer 7))
  1365.          (day (% omer 7)))
  1366.     (if (and (> omer 0) (< omer 50))
  1367.         (format "Day %d%s of the omer (until sunset)"
  1368.                 omer
  1369.                 (if (zerop week)
  1370.                     ""
  1371.                   (format ", that is, %d week%s%s"
  1372.                           week
  1373.                           (if (= week 1) "" "s")
  1374.                           (if (zerop day)
  1375.                               ""
  1376.                             (format " and %d day%s"
  1377.                                     day (if (= day 1) "" "s")))))))))
  1378.  
  1379. (defun diary-yahrzeit (death-month death-day death-year)
  1380.   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
  1381. Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
  1382. to be the name of the person.  Date of death is on the *civil* calendar;
  1383. although the date of death is specified by the civil calendar, the proper
  1384. Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
  1385. order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
  1386.   (let* ((h-date (calendar-hebrew-from-absolute
  1387.                   (calendar-absolute-from-gregorian
  1388.                    (if european-calendar-style
  1389.                        (list death-day death-month death-year)
  1390.                    (list death-month death-day death-year)))))
  1391.          (h-month (extract-calendar-month h-date))
  1392.          (h-day (extract-calendar-day h-date))
  1393.          (h-year (extract-calendar-year h-date))
  1394.          (d (calendar-absolute-from-gregorian date))
  1395.          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
  1396.          (diff (- yr h-year))
  1397.          (y (hebrew-calendar-yahrzeit h-date yr)))
  1398.     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
  1399.         (format "Yahrzeit of %s%s: %d%s anniversary"
  1400.                 entry
  1401.                 (if (= y d) "" " (evening)")
  1402.                 diff
  1403.                 (cond ((= (% diff 10) 1) "st")
  1404.                       ((= (% diff 10) 2) "nd")
  1405.                       ((= (% diff 10) 3) "rd")
  1406.                       (t "th"))))))
  1407.  
  1408. (defun diary-rosh-hodesh ()
  1409.   "Rosh Hodesh diary entry.
  1410. Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
  1411.   (let* ((d (calendar-absolute-from-gregorian date))
  1412.          (h-date (calendar-hebrew-from-absolute d))
  1413.          (h-month (extract-calendar-month h-date))
  1414.          (h-day (extract-calendar-day h-date))
  1415.          (h-year (extract-calendar-year h-date))
  1416.          (leap-year (hebrew-calendar-leap-year-p h-year))
  1417.          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
  1418.          (h-month-names
  1419.           (if leap-year
  1420.               calendar-hebrew-month-name-array-leap-year
  1421.             calendar-hebrew-month-name-array-common-year))
  1422.          (this-month (aref h-month-names (1- h-month)))
  1423.          (h-yesterday (extract-calendar-day
  1424.                        (calendar-hebrew-from-absolute (1- d)))))
  1425.     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
  1426.         (format
  1427.          "Rosh Hodesh %s"
  1428.          (if (= h-day 30)
  1429.              (format
  1430.               "%s (first day)"
  1431.               ;; next month must be in the same year since this
  1432.               ;; month can't be the last month of the year since
  1433.               ;; it has 30 days
  1434.               (aref h-month-names h-month))
  1435.            (if (= h-yesterday 30)
  1436.                (format "%s (second day)" this-month)
  1437.              this-month)))
  1438.       (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
  1439.           (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
  1440.                  (format "Mevarhim Rosh Hodesh %s (%s)"
  1441.                          (aref h-month-names
  1442.                                (if (= h-month
  1443.                                       (hebrew-calendar-last-month-of-year
  1444.                                        h-year))
  1445.                                    0 h-month))
  1446.                          (aref calendar-day-name-array (- 29 h-day))))
  1447.                 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
  1448.                  (format "Mevarhim Rosh Hodesh %s (%s-%s)"
  1449.                          (aref h-month-names h-month)
  1450.                          (if (= h-day 29)
  1451.                              "tomorrow"
  1452.                            (aref calendar-day-name-array (- 29 h-day)))
  1453.                          (aref calendar-day-name-array
  1454.                                (% (- 30 h-day) 7)))))
  1455.         (if (and (= h-day 29) (/= h-month 6))
  1456.             (format "Erev Rosh Hodesh %s"
  1457.                     (aref h-month-names
  1458.                           (if (= h-month
  1459.                                  (hebrew-calendar-last-month-of-year
  1460.                                   h-year))
  1461.                               0 h-month))))))))
  1462.  
  1463. (defun diary-parasha ()
  1464.   "Parasha diary entry--entry applies if date is a Saturday."
  1465.   (let ((d (calendar-absolute-from-gregorian date)))
  1466.     (if (= (% d 7) 6);;  Saturday
  1467.         (let*
  1468.             ((h-year (extract-calendar-year
  1469.                       (calendar-hebrew-from-absolute d)))
  1470.              (rosh-hashannah
  1471.               (calendar-absolute-from-hebrew (list 7 1 h-year)))
  1472.              (passover
  1473.               (calendar-absolute-from-hebrew (list 1 15 h-year)))
  1474.              (rosh-hashannah-day
  1475.               (aref calendar-day-name-array (% rosh-hashannah 7)))
  1476.              (passover-day
  1477.               (aref calendar-day-name-array (% passover 7)))
  1478.              (long-h (hebrew-calendar-long-heshvan-p h-year))
  1479.              (short-k (hebrew-calendar-short-kislev-p h-year))
  1480.              (type (cond ((and long-h (not short-k)) "complete")
  1481.                          ((and (not long-h) short-k) "incomplete")
  1482.                          (t "regular")))
  1483.              (year-format
  1484.               (symbol-value
  1485.                (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
  1486.                                rosh-hashannah-day type passover-day))))
  1487.              (first-saturday;; of Hebrew year
  1488.               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
  1489.              (saturday;; which Saturday of the Hebrew year
  1490.               (/ (- d first-saturday) 7))
  1491.              (parasha (aref year-format saturday)))
  1492.           (if parasha
  1493.               (format
  1494.                "Parashat %s"
  1495.                (if (listp parasha);; Israel differs from diaspora
  1496.                    (if (car parasha)
  1497.                        (format "%s (diaspora), %s (Israel)"
  1498.                                (hebrew-calendar-parasha-name (car parasha))
  1499.                                (hebrew-calendar-parasha-name (cdr parasha)))
  1500.                      (format "%s (Israel)"
  1501.                              (hebrew-calendar-parasha-name (cdr parasha))))
  1502.                  (hebrew-calendar-parasha-name parasha))))))))
  1503.  
  1504. (defun add-to-diary-list (date string)
  1505.   "Add the entry (DATE STRING) to `diary-entries-list'.
  1506. Do nothing if DATE or STRING is nil."
  1507.   (and date string
  1508.        (setq diary-entries-list 
  1509.              (append diary-entries-list (list (list date string))))))
  1510.  
  1511. (defvar hebrew-calendar-parashiot-names
  1512. ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
  1513.  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
  1514.  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
  1515.  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
  1516.  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
  1517.  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
  1518.  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
  1519.  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
  1520.  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
  1521.   "The names of the parashiot in the Torah.")
  1522.  
  1523. ;; The seven ordinary year types (keviot)
  1524.  
  1525. (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
  1526.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1527.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1528.     43 44 45 46 47 48 49 50]
  1529.   "The structure of the parashiot.
  1530. Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
  1531. 29 days), and has Passover start on Sunday.")
  1532.  
  1533. (defconst hebrew-calendar-year-Saturday-complete-Tuesday
  1534.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1535.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1536.     43 44 45 46 47 48 49 [50 51]]
  1537.   "The structure of the parashiot.
  1538. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1539. have 30 days), and has Passover start on Tuesday.")
  1540.  
  1541. (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
  1542.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1543.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1544.     43 44 45 46 47 48 49 [50 51]]
  1545.   "The structure of the parashiot.
  1546. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1547. have 29 days), and has Passover start on Tuesday.")
  1548.  
  1549. (defconst hebrew-calendar-year-Monday-complete-Thursday
  1550.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1551.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1552.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1553.   "The structure of the parashiot.
  1554. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1555. 30 days), and has Passover start on Thursday.")
  1556.  
  1557. (defconst hebrew-calendar-year-Tuesday-regular-Thursday
  1558.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1559.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1560.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1561.   "The structure of the parashiot.
  1562. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1563. Kislev has 30 days), and has Passover start on Thursday.")
  1564.  
  1565. (defconst hebrew-calendar-year-Thursday-regular-Saturday
  1566.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
  1567.    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
  1568.    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
  1569.    49 50]
  1570.   "The structure of the parashiot.
  1571. Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
  1572. Kislev has 30 days), and has Passover start on Saturday.")
  1573.  
  1574. (defconst hebrew-calendar-year-Thursday-complete-Sunday
  1575.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1576.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1577.     43 44 45 46 47 48 49 50]
  1578.   "The structure of the parashiot.
  1579. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
  1580. have 30 days), and has Passover start on Sunday.")
  1581.  
  1582. ;; The seven leap year types (keviot)
  1583.  
  1584. (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
  1585.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1586.     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
  1587.     43 44 45 46 47 48 49 [50 51]]
  1588.   "The structure of the parashiot.
  1589. Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
  1590. have 29 days), and has Passover start on Tuesday.")
  1591.  
  1592. (defconst hebrew-calendar-year-Saturday-complete-Thursday
  1593.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1594.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1595.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1596.   "The structure of the parashiot.
  1597. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1598. have 30 days), and has Passover start on Thursday.")
  1599.  
  1600. (defconst hebrew-calendar-year-Monday-incomplete-Thursday
  1601.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1602.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1603.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1604.   "The structure of the parashiot.
  1605. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1606. have 29 days), and has Passover start on Thursday.")
  1607.  
  1608. (defconst hebrew-calendar-year-Monday-complete-Saturday
  1609.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1610.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1611.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1612.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1613.   "The structure of the parashiot.
  1614. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1615. 30 days), and has Passover start on Saturday.")
  1616.  
  1617. (defconst hebrew-calendar-year-Tuesday-regular-Saturday
  1618.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1619.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1620.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1621.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1622.   "The structure of the parashiot.
  1623. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1624. Kislev has 30 days), and has Passover start on Saturday.")
  1625.  
  1626. (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
  1627.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1628.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1629.     43 44 45 46 47 48 49 50]
  1630.   "The structure of the parashiot.
  1631. Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
  1632. have 29 days), and has Passover start on Sunday.")
  1633.  
  1634. (defconst hebrew-calendar-year-Thursday-complete-Tuesday
  1635.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1636.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1637.     43 44 45 46 47 48 49 [50 51]]
  1638.   "The structure of the parashiot.
  1639. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
  1640. have 30 days), and has Passover start on Tuesday.")
  1641.  
  1642. (defun hebrew-calendar-parasha-name (p)
  1643.   "Name(s) corresponding to parasha P."
  1644.   (if (arrayp p);; combined parasha
  1645.       (format "%s/%s"
  1646.               (aref hebrew-calendar-parashiot-names (aref p 0))
  1647.               (aref hebrew-calendar-parashiot-names (aref p 1)))
  1648.     (aref hebrew-calendar-parashiot-names p)))
  1649.  
  1650. (defun list-islamic-diary-entries ()
  1651.   "Add any Islamic date entries from the diary file to `diary-entries-list'.
  1652. Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
  1653. \(normally an `I').  The same diary date forms govern the style of the Islamic
  1654. calendar entries, except that the Islamic month names must be spelled in full.
  1655. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1656. Dhu al-Hijjah.  If an Islamic date diary entry begins with a
  1657. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  1658. not be marked in the calendar.  This function is provided for use with the
  1659. `nongregorian-diary-listing-hook'."
  1660.   (if (< 0 number)
  1661.       (let ((buffer-read-only nil)
  1662.             (diary-modified (buffer-modified-p))
  1663.             (gdate original-date)
  1664.             (mark (regexp-quote diary-nonmarking-symbol)))
  1665.         (calendar-for-loop i from 1 to number do
  1666.            (let* ((d diary-date-forms)
  1667.                   (idate (calendar-islamic-from-absolute 
  1668.                           (calendar-absolute-from-gregorian gdate)))
  1669.                   (month (extract-calendar-month idate))
  1670.                   (day (extract-calendar-day idate))
  1671.                   (year (extract-calendar-year idate)))
  1672.              (while d
  1673.                (let*
  1674.                    ((date-form (if (equal (car (car d)) 'backup)
  1675.                                    (cdr (car d))
  1676.                                  (car d)))
  1677.                     (backup (equal (car (car d)) 'backup))
  1678.                     (dayname
  1679.                      (concat
  1680.                       (calendar-day-name gdate) "\\|"
  1681.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  1682.                     (calendar-month-name-array
  1683.                      calendar-islamic-month-name-array)
  1684.                     (monthname
  1685.                      (concat
  1686.                       "\\*\\|"
  1687.                       (calendar-month-name month)))
  1688.                     (month (concat "\\*\\|0*" (int-to-string month)))
  1689.                     (day (concat "\\*\\|0*" (int-to-string day)))
  1690.                     (year
  1691.                      (concat
  1692.                       "\\*\\|0*" (int-to-string year)
  1693.                       (if abbreviated-calendar-year
  1694.                           (concat "\\|" (int-to-string (% year 100)))
  1695.                         "")))
  1696.                     (regexp
  1697.                      (concat
  1698.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  1699.                       (regexp-quote islamic-diary-entry-symbol)
  1700.                       "\\("
  1701.                       (mapconcat 'eval date-form "\\)\\(")
  1702.                       "\\)"))
  1703.                     (case-fold-search t))
  1704.                  (goto-char (point-min))
  1705.                  (while (re-search-forward regexp nil t)
  1706.                    (if backup (re-search-backward "\\<" nil t))
  1707.                    (if (and (or (char-equal (preceding-char) ?\^M)
  1708.                                 (char-equal (preceding-char) ?\n))
  1709.                             (not (looking-at " \\|\^I")))
  1710.                        ;;  Diary entry that consists only of date.
  1711.                        (backward-char 1)
  1712.                      ;;  Found a nonempty diary entry--make it visible and
  1713.                      ;;  add it to the list.
  1714.                      (let ((entry-start (point))
  1715.                            (date-start))
  1716.                        (re-search-backward "\^M\\|\n\\|\\`")
  1717.                        (setq date-start (point))
  1718.                        (re-search-forward "\^M\\|\n" nil t 2)
  1719.                        (while (looking-at " \\|\^I")
  1720.                          (re-search-forward "\^M\\|\n" nil t))
  1721.                        (backward-char 1)
  1722.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  1723.                        (add-to-diary-list
  1724.                          gdate (buffer-substring entry-start (point)))))))
  1725.                (setq d (cdr d))))
  1726.            (setq gdate
  1727.                  (calendar-gregorian-from-absolute
  1728.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  1729.            (set-buffer-modified-p diary-modified))
  1730.         (goto-char (point-min))))
  1731.  
  1732. (defun mark-islamic-diary-entries ()
  1733.   "Mark days in the calendar window that have Islamic date diary entries.
  1734. Each entry in diary-file (or included files) visible in the calendar window
  1735. is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
  1736. \(normally an `I').  The same diary-date-forms govern the style of the Islamic
  1737. calendar entries, except that the Islamic month names must be spelled in full.
  1738. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1739. Dhu al-Hijjah.  Islamic date diary entries that begin with a
  1740. diary-nonmarking-symbol will not be marked in the calendar.  This function is
  1741. provided for use as part of the nongregorian-diary-marking-hook."
  1742.   (let ((d diary-date-forms))
  1743.     (while d
  1744.       (let*
  1745.           ((date-form (if (equal (car (car d)) 'backup)
  1746.                           (cdr (car d))
  1747.                         (car d)));; ignore 'backup directive
  1748.            (dayname (diary-name-pattern calendar-day-name-array))
  1749.            (monthname
  1750.             (concat
  1751.              (diary-name-pattern calendar-islamic-month-name-array t)
  1752.              "\\|\\*"))
  1753.            (month "[0-9]+\\|\\*")
  1754.            (day "[0-9]+\\|\\*")
  1755.            (year "[0-9]+\\|\\*")
  1756.            (l (length date-form))
  1757.            (d-name-pos (- l (length (memq 'dayname date-form))))
  1758.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  1759.            (m-name-pos (- l (length (memq 'monthname date-form))))
  1760.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  1761.            (d-pos (- l (length (memq 'day date-form))))
  1762.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  1763.            (m-pos (- l (length (memq 'month date-form))))
  1764.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  1765.            (y-pos (- l (length (memq 'year date-form))))
  1766.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  1767.            (regexp
  1768.             (concat
  1769.              "\\(\\`\\|\^M\\|\n\\)"
  1770.              (regexp-quote islamic-diary-entry-symbol)
  1771.              "\\("
  1772.              (mapconcat 'eval date-form "\\)\\(")
  1773.              "\\)"))
  1774.            (case-fold-search t))
  1775.         (goto-char (point-min))
  1776.         (while (re-search-forward regexp nil t)
  1777.           (let* ((dd-name
  1778.                   (if d-name-pos
  1779.                       (buffer-substring
  1780.                        (match-beginning d-name-pos)
  1781.                        (match-end d-name-pos))))
  1782.                  (mm-name
  1783.                   (if m-name-pos
  1784.                       (buffer-substring
  1785.                        (match-beginning m-name-pos)
  1786.                        (match-end m-name-pos))))
  1787.                  (mm (string-to-int
  1788.                       (if m-pos
  1789.                           (buffer-substring
  1790.                            (match-beginning m-pos)
  1791.                            (match-end m-pos))
  1792.                         "")))
  1793.                  (dd (string-to-int
  1794.                       (if d-pos
  1795.                           (buffer-substring
  1796.                            (match-beginning d-pos)
  1797.                            (match-end d-pos))
  1798.                         "")))
  1799.                  (y-str (if y-pos
  1800.                             (buffer-substring
  1801.                              (match-beginning y-pos)
  1802.                              (match-end y-pos))))
  1803.                  (yy (if (not y-str)
  1804.                          0
  1805.                        (if (and (= (length y-str) 2)
  1806.                                 abbreviated-calendar-year)
  1807.                            (let* ((current-y
  1808.                                    (extract-calendar-year
  1809.                                     (calendar-islamic-from-absolute
  1810.                                      (calendar-absolute-from-gregorian
  1811.                                       (calendar-current-date)))))
  1812.                                   (y (+ (string-to-int y-str)
  1813.                                         (* 100 (/ current-y 100)))))
  1814.                              (if (> (- y current-y) 50)
  1815.                                  (- y 100)
  1816.                                (if (> (- current-y y) 50)
  1817.                                    (+ y 100)
  1818.                                  y)))
  1819.                          (string-to-int y-str)))))
  1820.             (if dd-name
  1821.                 (mark-calendar-days-named
  1822.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  1823.                              (calendar-make-alist
  1824.                                calendar-day-name-array
  1825.                                0
  1826.                                '(lambda (x) (substring x 0 3))))))
  1827.               (if mm-name
  1828.                   (if (string-equal mm-name "*")
  1829.                       (setq mm 0)
  1830.                     (setq mm
  1831.                           (cdr (assoc
  1832.                                 (capitalize mm-name)
  1833.                                 (calendar-make-alist
  1834.                                   calendar-islamic-month-name-array))))))
  1835.               (mark-islamic-calendar-date-pattern mm dd yy)))))
  1836.       (setq d (cdr d)))))
  1837.  
  1838. (defun mark-islamic-calendar-date-pattern (month day year)
  1839.   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
  1840. A value of 0 in any position is a wildcard."
  1841.   (save-excursion
  1842.     (set-buffer calendar-buffer)
  1843.     (if (and (/= 0 month) (/= 0 day))
  1844.         (if (/= 0 year)
  1845.             ;; Fully specified Islamic date.
  1846.             (let ((date (calendar-gregorian-from-absolute
  1847.                          (calendar-absolute-from-islamic
  1848.                           (list month day year)))))
  1849.               (if (calendar-date-is-visible-p date)
  1850.                   (mark-visible-calendar-date date)))
  1851.           ;; Month and day in any year--this taken from the holiday stuff.
  1852.           (let* ((islamic-date (calendar-islamic-from-absolute
  1853.                                 (calendar-absolute-from-gregorian
  1854.                                  (list displayed-month 15 displayed-year))))
  1855.                  (m (extract-calendar-month islamic-date))
  1856.                  (y (extract-calendar-year islamic-date))
  1857.                  (date))
  1858.             (if (< m 1)
  1859.                 nil;;   Islamic calendar doesn't apply.
  1860.               (increment-calendar-month m y (- 10 month))
  1861.               (if (> m 7);;  Islamic date might be visible
  1862.                   (let ((date (calendar-gregorian-from-absolute
  1863.                                (calendar-absolute-from-islamic
  1864.                                 (list month day y)))))
  1865.                     (if (calendar-date-is-visible-p date)
  1866.                         (mark-visible-calendar-date date)))))))
  1867.       ;; Not one of the simple cases--check all visible dates for match.
  1868.       ;; Actually, the following code takes care of ALL of the cases, but
  1869.       ;; it's much too slow to be used for the simple (common) cases.
  1870.       (let ((m displayed-month)
  1871.             (y displayed-year)
  1872.             (first-date)
  1873.             (last-date))
  1874.         (increment-calendar-month m y -1)
  1875.         (setq first-date
  1876.               (calendar-absolute-from-gregorian
  1877.                (list m 1 y)))
  1878.         (increment-calendar-month m y 2)
  1879.         (setq last-date
  1880.               (calendar-absolute-from-gregorian
  1881.                (list m (calendar-last-day-of-month m y) y)))
  1882.         (calendar-for-loop date from first-date to last-date do
  1883.           (let* ((i-date (calendar-islamic-from-absolute date))
  1884.                  (i-month (extract-calendar-month i-date))
  1885.                  (i-day (extract-calendar-day i-date))
  1886.                  (i-year (extract-calendar-year i-date)))
  1887.             (and (or (zerop month)
  1888.                      (= month i-month))
  1889.                  (or (zerop day)
  1890.                      (= day i-day))
  1891.                  (or (zerop year)
  1892.                      (= year i-year))
  1893.                  (mark-visible-calendar-date
  1894.                   (calendar-gregorian-from-absolute date)))))))))
  1895.  
  1896. (provide 'diary-lib)
  1897.  
  1898. ;;; diary-lib.el ends here
  1899.